perm filename ACS.OLD[1,LCS] blob sn#086989 filedate 1974-02-07 generic text, type T, neo UTF8
00100		SUBROUTINE ACSHFT(RX)
00200		COMMON/SS/Y,RH,RN1 /XRN/RN(4000)
00500		COMMON /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA
00600		1,DBST,NFLG,IXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA
00900		DIMENSION R(8,100)
01000		EQUIVALENCE (R,RN(3001))
01100		L=K-1
01200		M=L-ABS(RX)
01300		JD=1
01400		RN1=99
01500	CC	RD=20
01600		Y=-.23
01700		IF(RX.LT.0)GO TO 1
01800		L=M
01900		M=K-1
02000		JD=-1
02100	CC	RD=10
02200	1	DO 2 N=M,L,JD
02300	C  DOES IT HAVE AN ACCID?
02400		IF(AMOD(R(5,N),10.).EQ.0)GO TO 2
02410		X=0
02500	C  IS THIS THE FIRST ACCID?
02600		IF(RN1.NE.99)GO TO 3
02700		RN1=R(4,N)
02800		GO TO 4
02900	3	RH=R(4,N)
03000		IF(ABS(RH-RN1).LT.5)GO TO 4
03100		RN1=RH
03200		Y=-.23
03300	CC	GO TO 2
03350	4	CALL SHFT
03375	CC	IF(Y.GE.1)Y=0
03400	       IF((R(6,N+JD).EQ.20.OR.R(6,N-JD).EQ.20).AND.Y.EQ.0)CALL SHFT
03450		IF(R(6,N).EQ.10)X=.23
03500		IF(R(6,N).EQ.20.AND.Y.GE..23)Y=Y-.23
03600	CC	IF(Y.GE.1.)Y=.23
03700	C  SO Y DOESN'T GET >1.
03800	5	R(5,N)=R(5,N)+X+Y
03900	2	CONTINUE
04000		END
04100	
04200		SUBROUTINE SHFT
04300		COMMON/SS/Y,RH,RN1
04400		Y=Y+.23
04500		IF(Y.LT.1)RETURN
04600		RN1=RH
04700		Y=0
04800		END